home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr52 / clmsflpc.zip / BIN.PRG < prev   
Text File  |  1993-06-24  |  4KB  |  166 lines
  1. /*
  2.    ===============================================================
  3.          Quick BASIC numeral conversion routines for CLIPPER
  4.                           PUBLIC DOMAIN
  5.                        cheerfully provided
  6.                       by Staben Technologies
  7.                        811 West 14th Avenue
  8.                     Spokane, Washington  99204
  9.    ===============================================================
  10. */
  11.  
  12. FUNCTION BIN2DEC(binval)
  13. local pt1, pt2, value, y, x
  14. /*
  15.    routine to convert a binary number to a decimal.  Decimal points
  16.    will be used to separate the whole from the fractional part
  17.                   n+1    n         0     -1    -2       -n    -n-1
  18.                 2^   + 2^  ... + 2^  + 2^  + 2^   ... 2^  + 2^
  19.                 --------------------   -----------------------
  20.                       Whole Part     .      Fractional Part
  21. */
  22.  
  23. /* find a decimal point, and split it */
  24.  
  25. if "."$binval
  26.    pt1 := subs(binval,1,at('.',binval)-1)
  27.    pt2 := subs(binval,at('.',binval)+1)
  28. else
  29.    pt1 := binval
  30.    pt2 := ""
  31. endif
  32.  
  33. value := 0
  34. y := 0
  35. /* whole portion */
  36. for x := len(pt1) to 1 step -1
  37.     if subs(pt1,x,1) == "1"
  38.        value := value+2^y
  39.     endif
  40.     y := y+1
  41. next
  42. /* fractional portion */
  43. if len(pt2) > 0
  44.    y := -1
  45.    for x := 1 to len(pt2)
  46.        if subs(pt2,x,1) == "1"
  47.           value := value+2^y
  48.        endif
  49.        y := y-1
  50.    next
  51. endif
  52. return(value)
  53.  
  54. FUNCTION DEC2BIN(value,length)
  55.  
  56. local done, hibit, x, subvalue, binval
  57. /* first find highest bit */
  58.  
  59. if length == NIL
  60.    length := 64
  61. endif
  62. done := .f.
  63. hibit := 0
  64. do while .not. done
  65.    if 2^hibit > value
  66.       done := .t.
  67.    else
  68.       hibit := hibit+1
  69.    endif
  70. enddo
  71.  
  72. /* create string */
  73.  
  74.  
  75. binval := ""
  76. subvalue := int(value)
  77. /* first, the whole value */
  78. for x := hibit to 0 step -1
  79.     if 2^x <= subvalue
  80.        binval := binval + "1"
  81.        subvalue := subvalue - 2^x
  82.     else
  83.        binval := binval + "0"
  84.     endif
  85. next
  86.  
  87. /* second, the fractional portion */
  88. subvalue := value - int(value)
  89. if subvalue > 0
  90.    binval := binval + "."
  91.    /* do the decimal portion */
  92.    done := .f.
  93.    x := -1
  94.    do while .not. done
  95.       if subvalue >= 2^x
  96.          subvalue := subvalue - 2^x
  97.          binval := binval + "1"
  98.       else
  99.          binval := binval + "0"
  100.       endif
  101.       if subvalue <= 0 .or. subvalue == 0 .or. subvalue < 0.00001
  102.          done := .t.
  103.       endif
  104.       x := x-1
  105.    enddo
  106. endif
  107. /* and pad it up */
  108. binval := repl('0',64)+binval
  109. binval := subs(binval,(len(binval)-length)+1)
  110. return(binval)
  111.  
  112. FUNCTION cvi(strng)
  113. local first,last,total
  114. /*
  115.   Simple function convert a two-byte string to numbers *integer*
  116.   (BASIC's CVI() function)
  117. */
  118.  
  119. first := asc(subs(strng,1,1))
  120. last := asc(subs(strng,2,1))
  121. total := first+(last*256)
  122. return(total)
  123.  
  124. FUNCTION cv(strng)
  125. /*
  126.   Simple function convert up to 64-bit precision a number stored as a string
  127.   in MICROSOFT FLOATING POINT FORMAT (cvs(), cvd(), etc.)
  128. */
  129.  
  130.  
  131. local b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16,b17,b18,b19,b20
  132. local b21,b22,b23,b24,b25,b26,b27,b28,b29,b30,b31,b32,b33,b34,b35,b36,b37,b38
  133. local b39,b40,b41,b42,b43,b44,b45,b46,b47,b48,b49,b50,b51,b52,b53,b54,b55,b56
  134. local b57,b58,b59,b60,b61,b62,b63,b64
  135. local nvar
  136.  
  137. local realbinary,mantissa,exponent,positive,realvalue
  138. local x
  139. if strng == repl(chr(0),len(strng))
  140.    return(0)
  141. endif
  142.  
  143. for x := 1 to len(strng)
  144.     nvar := "b"+alltrim(str(x))
  145.     &nvar := dec2bin(asc(subs(strng,x,1)),8)
  146. next
  147.  
  148. realbinary := ""
  149. for x := len(strng) to 1 step -1
  150.     nvar := "b"+alltrim(str(x))
  151.     realbinary := realbinary+&nvar
  152. next
  153. exponent := asc(subs(strng,len(strng),1)) - 128
  154. positive := if(subs(realbinary,9,1) == "0",.T.,.F.)
  155. mantissa := "1"+subs(realbinary,10,23)
  156. if exponent > 0
  157.    realvalue := bin2dec(subs(mantissa,1,exponent)+"."+subs(mantissa,exponent+1))
  158. else
  159.    realvalue := bin2dec("."+repl("0",-1*exponent)+mantissa)
  160. endif
  161. if .not. positive
  162.    realvalue := realvalue * -1
  163. endif
  164. return(realvalue)
  165.  
  166.